PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/win/pascal/tpwgray.com/TPWGRAYS.PAS

Pascal/Delphi Source File | 1991-05-31 | 5.3 KB | 197 lines

{TPWGRAYS.PAS - a TPW/ObjectVision version of Grays.C (C) Copyright Charles Petzold 1990}
{Adaption D.Overmyer}
program TPWGRAYS;
{$R TPWGRAYS.RES}

uses WinTypes, WinProcs, WObjects, Strings;

const
  PG_Name =  'TPWGRAYS';
  cm_Dithered = 1;
  cm_PaletteRGB = 2;
  cm_PaletteIndex = 3;
{*****************************************************************}
{T Y P E S }
{*****************************************************************}
type

{ TPGApplication, a TApplication descendant }
  TPGApplication = object(TApplication)
    procedure InitMainWindow; virtual;
  end;

{ TPGWindow, a TWindow descendant }
  PPGWindow = ^TPGWindow;
  TPGWindow = object(TWindow)
    hPal :HPalette;
    cxClient,cyClient:Word;
    wDisplay:Word;
    constructor Init(AParent:PWindowsObject;ATitle: PChar);
    destructor Done; virtual;
    function  Min(i,j:Integer):integer;virtual;
    procedure CMDithered(var msg:TMessage);virtual cm_First+cm_Dithered;
    procedure CMPaletteRGB(var Msg:TMessage);virtual cm_First+cm_PaletteRGB;
    procedure CMPaletteIndex(var Msg:TMessage);virtual cm_First+cm_PaletteIndex;
    procedure UpdateMenu(var Msg:TMessage);virtual;
    procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
    procedure WMQueryNewPalette(var Msg:TMessage);virtual wm_First+wm_QueryNewPalette;
    procedure WMPaletteChanged(var Msg:TMessage);virtual wm_First+wm_PaletteChanged;
    procedure WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
  end;

{*****************************************************************}
{M E T H O D S }
{*****************************************************************}

{ Construct the TPGApp's MainWindow of type TPGWindow }
procedure TPGApplication.InitMainWindow;
begin
  MainWindow := New(PPGWindow, Init(nil,PG_name));
end;

constructor TPGWindow.Init(AParent:PWindowsObject;ATitle: PChar);
var
  plp :PLogPalette;
  i :Integer;
  rc :TRect;
  nGrayLevel:Byte;
  size  : Word;
begin
{$R-}   {Must disable range checking for plp due to TLogPalette declaration}
  TWindow.Init(nil, ATitle);
  Attr.Style := Attr.Style or ws_VScroll or ws_HScroll;
  Attr.Menu := LoadMenu(HInstance, 'PG_Menu');
  size := sizeof(TLogPalette)+64*sizeof(TPaletteEntry);
  plp := MemAlloc(size);
  plp^.palVersion := $0300;
  plp^.palNumEntries := 65;
  for i := 0 to  64 do
          begin
      nGrayLevel := min(255,4*i);
      plp^.palPalEntry[i].peRed := nGrayLevel;
      plp^.palPalEntry[i].peGreen := nGrayLevel;
      plp^.palPalEntry[i].peBlue := nGrayLevel;
      plp^.palPalEntry[i].peFlags := 0;
  end;
  hPal := CreatePalette(plp^);
  Freemem(plp,size);
  wDisplay := cm_Dithered;
  {$R+}
end;

destructor TPGWindow.Done;
begin
  DeleteObject(HPal);
  TWindow.Done;
end;

function TPGWindow.Min(i,j:integer):integer;
begin
    min := j;
    if i<j then min := i;
end;

procedure TPGWindow.UpdateMenu(var Msg: TMessage);
begin
    CheckMenuItem(Attr.Menu,wDisplay,MF_UnChecked);
   wDisplay := Msg.wParam;
   CheckMenuItem(Attr.Menu,wdisplay,MF_Checked);
   InvalidateRect(HWindow,nil,True);
end;

procedure TPGWindow.CMDithered(var Msg: TMessage);
begin
    UpdateMenu(Msg);
end;

procedure TPGWindow.CMPaletteRGB(var Msg: TMessage);
begin
    UpdateMenu(Msg);
end;

procedure TPGWindow.CMPaletteIndex(var Msg: TMessage);
begin
    UpdateMenu(Msg);
end;

procedure TPGWindow.WMSize(var Msg:TMessage);
begin
    cxClient := Msg.LParamLo;
   cyClient := Msg.LParamHi;
end;

procedure TPGWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
    i : Integer;
   aBrush : HBrush;
   rc : TRect;
   nGrayLevel:word;
   hOldPal : HPalette;
begin
if (wDisplay <> cm_Dithered) then
    begin
   hOldPal :=SelectPalette(PaintDC,hPal,False);
   RealizePalette(PaintDC);
    end;
for i := 0 to 64 do
    begin
   rc.left := Integer(i * cxClient div 65);
   rc.top := 0;
   rc.right := Integer((i+1) * cxClient div 65);
   rc.bottom := cyClient;
   nGrayLevel := min(255,4*i);
   if wDisplay = cm_Dithered then
       aBrush := CreateSolidBrush(RGB(nGrayLevel,nGrayLevel,nGrayLevel));
   if wDisplay = cm_PaletteRGB then
       aBrush := CreateSolidBrush(PaletteRGB(nGrayLevel,nGrayLevel,nGrayLevel));
   if wDisplay = cm_PaletteIndex then
       aBrush := CreateSolidBrush(PaletteIndex(i));
   FillRect(PaintDC,rc,aBrush);
   DeleteObject(aBrush);
   end;
if (wDisplay <> cm_Dithered) then SelectPalette(PaintDC,hOldPal,False);
end;

procedure TPGWindow.WMQueryNewPalette(var Msg: TMessage);
var
    ahDC :HDC;
begin
ahDC := GetDC(HWindow);
SelectPalette(ahDC,hPal,False);
if (RealizePalette(ahDC) > 0) then
     begin
   ReleaseDC(HWindow,ahDC);
   InvalidateRect(HWindow,Nil,False)
   end
else
   ReleaseDC(HWindow,ahDC);
end;

procedure TPGWindow.WMPaletteChanged(var Msg: TMessage);
var
    ahDC : HDC;
begin
if (Msg.wParam <> HWindow) then
    begin
   ahDC := GetDC(HWindow);
   SelectPalette(ahDC,hPal,False);
   if (RealizePalette(ahDC) > 0) then
       InvalidateRect(HWindow,nil,False);
   ReleaseDC(HWindow,ahDC);
   end;
end;

{*****************************************************************}
{M A I N    L I N E }
{*****************************************************************}
{ Declare a variable of type TPGApp }
var
  PGApp: TPGApplication;

{ Run the PGApp }
begin
  PGApp.Init('TPWGRAYS');
  PGApp.Run;
  PGApp.Done;
end.